home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / Pocket Forth rel.5 / Text files / Misc < prev    next >
Encoding:
Text File  |  1991-07-21  |  2.4 KB  |  60 lines  |  [TEXT/EDIT]
  1. ( Misc extras ) decimal
  2.  
  3. : EVEN ( n -- n' ) dup 2 mod + ;  ( round n up to an even number )
  4. : ," ( -- ) ( compile a quoted string from input stream )
  5.     34 word here c@ 1+ even allot ; IMMEDIATE
  6.  
  7. : TO ( n -- ) ' 2+ ! ;  ( set the value of a constant )
  8.  
  9. : ?COLOR ( -- f ) ( true if color is available )
  10.     here dup >abs
  11.     ,$ 205E   ( movea.l [ps]+,a0 )
  12.     ,$ 7001   ( moveq.l #$01,d0 )
  13.     ,$ A090   ( _SysEnvirons )
  14.     9 + c@ ;  ( color qd available? )
  15.  
  16. : ?DA ( -- flag ) ( true if the DA type is running )
  17.     0 +md 2@  ( the window's pointer )
  18.     108 0 d+ l@  0< ; ( the windowKind integer<0 if DA kind )
  19.  
  20. : SHRINK ( -- ) ( shrinks free space to 84 bytes )
  21.     room 84 -  ( size in excess of 84 bytes )
  22.     negate grow ;  ( shrink it )
  23.  
  24. : XSIZE ( h v -- ) ( change the window size )
  25.     2dup  8 +md 2!  ( set the scroll rect )
  26.     0 +md 2@ 2>r  2>r  0 >r  ,$ A91D ; ( _SizeWindow )
  27.  
  28. : SPACES ( n -- ) 0 DO space LOOP ;  ( emit n spaces )
  29. : H.2 ( n -- ) ( print a hex number, at least 2 characters long )
  30.     base @ >r hex  dup 16 < IF 0 . 8 emit THEN  .  r> base ! ;
  31. : A. ( addr -- ) h.2 8 emit ." :" 2 spaces ;  ( print address )
  32. : DUMP ( addr len -- ) ( do a formatted hex dump of memory )
  33.     swap dup -16 and swap dup a. over -  ( calc rounded start addr )
  34.     dup 0 DO 3 spaces LOOP ."  |"  rot +  ( indicate start addr )
  35.     over cr a.  0 DO  ( do for each len+[rounded.addr - real.addr])
  36.       dup r + c@ h.2  ( print byte value at addr + index )
  37.       r 1+ 16 mod 0= IF  ( break at end of 16 byte line )
  38.         ( 2 spaces dup r + 15 - 16 type  ( type the line ) ( long )
  39.         dup r + 1+ cr a. THEN LOOP  ( start a new line )
  40.     drop cr ;
  41.  
  42. : 00>R ( rstack: -- 0 0 ) ,$ 42A7 ; macro  ( clr.l -[rs] )
  43. : 2R ( -- d ) ( rstack: d -- d ) ,$ 2D17 ; macro  ( move.l [rs],-[ps] )
  44.  
  45. hex 5854 5445 2constant "TEXT" decimal
  46. : >CLIP ( c -- ) ( put a character on the clipboard from the stack )
  47.     256 *  ( move ascii data into byte position )
  48.     00>r ,$ A9FC 2r> 2drop  ( _ZeroScrap )
  49.     00>r  1 0 2>r  "TEXT" 2>r  sp@ 2>r  ,$ A9FE  ( _PutScrap )
  50.     2r> + IF beep THEN ;  ( beep on error )
  51.  
  52. : SP! ( -- ) s0@ ,$ 2C5E ;  ( move.l [ps]+,ps ) ( reset pstack )
  53. : RP! ( -- ) r0@ ,$ 2E5E ;  ( move.l [ps]+,rs ) ( reset rstack )
  54.  
  55. : NIP ( n1 n2 -- n2 ) ,$ 3C9E ; macro  ( move [ps]+,[ps] )
  56. : TUCK ( n1 n2 -- n2 n1 n2 ) swap over ;
  57.  
  58. : 2- ( n -- n-2 ) ,$ 5556 ; macro  ( subq #2,[ps] )
  59. : 4+ ( n -- n+4 ) ,$ 5856 ; macro  ( addq #4,[ps] )
  60.